home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 5 / Apprentice-Release5.iso / Environments / PowerMacOberon feb96 / Source / Calc.Mod (.txt) < prev    next >
Encoding:
Oberon Text  |  1994-07-11  |  11.3 KB  |  355 lines  |  [.Ob./.Ob4]
  1. Syntax10.Scn.Fnt
  2. StampElems
  3. Alloc
  4. 11 Jul 94
  5. Syntax10i.Scn.Fnt
  6. Syntax10b.Scn.Fnt
  7. MODULE Calc;    (** CAS 
  8.     IMPORT
  9.         SYSTEM, MathL, Reals, Texts, Oberon;
  10.     CONST
  11.         Version = "Calc  (cas 28 Sept 93)";
  12.         End = 7;    (*new scanner symbol*)
  13.         Eps = 1.0D-9; Eps0 = 0.5D-9;
  14.     TYPE
  15.         Symbol = POINTER TO SymbolDesc;
  16.         SymbolDesc = RECORD
  17.             name: ARRAY 32 OF CHAR;
  18.             funct: BOOLEAN;
  19.             val: LONGREAL;
  20.             next: Symbol
  21.         END;
  22.         lastTime: LONGINT;
  23.         W: Texts.Writer;
  24.         S: Texts.Scanner;
  25.         syms: Symbol;
  26.     (** expression syntax:
  27.         Expr = Term {AddOp Term}.
  28.         Term = Factor {MulOp Factor}.
  29.         Factor = Atom {PowOp Atom}.
  30.         Atom = Number | Functor Atom | ident | "(" Expr ")".
  31.         PowOp = "^".
  32.         MulOp = "*" | "/" | "%" | "<" | ">".    -- % modulo, < shift left, > shift right
  33.         AddOp = ["+" | "-"].    -- no add op: addition(!)
  34.         Number = (digit {digit}) | (digit {hexDigit} "H") | (digit {hexDigit} "X") | (""" char """).
  35.         Functor = "arccos" | "arcsin" | "arctan" | "cos" | "entier" | "exp" | "ln" | "short" | "sign" | "sin" | "sqrt" | "tan".
  36.     PROCEDURE err;
  37.     BEGIN S.class := Texts.Inval
  38.     END err;
  39.     PROCEDURE sign (n: LONGREAL): LONGREAL;
  40.     BEGIN
  41.         IF n < 0 THEN RETURN -1
  42.         ELSIF n = 0 THEN RETURN 0
  43.         ELSE RETURN 1 END
  44.     END sign;
  45.     PROCEDURE short (n: LONGREAL): REAL;
  46.     BEGIN RETURN SHORT(n + Eps0)
  47.     END short;
  48.     PROCEDURE entier (n: LONGREAL): LONGINT;
  49.     BEGIN RETURN ENTIER(n + Eps0)
  50.     END entier;
  51.     PROCEDURE sin (n: LONGREAL): LONGREAL;
  52.     BEGIN RETURN MathL.sin(n)
  53.     END sin;
  54.     PROCEDURE cos (n: LONGREAL): LONGREAL;
  55.     BEGIN RETURN MathL.cos(n)
  56.     END cos;
  57.     PROCEDURE tan (n: LONGREAL): LONGREAL;
  58.         VAR x: LONGREAL;
  59.     BEGIN x := MathL.cos(n);
  60.         IF x # 0 THEN RETURN MathL.sin(n) / x ELSE err; RETURN 1 END
  61.     END tan;
  62.     PROCEDURE arcsin (n: LONGREAL): LONGREAL;
  63.         VAR x: LONGREAL;
  64.     BEGIN x := MathL.sqrt(1 - n * n);
  65.         IF x # 0 THEN RETURN MathL.arctan(n / x) ELSE err; RETURN 1 END
  66.     END arcsin;
  67.     PROCEDURE arccos (n: LONGREAL): LONGREAL;
  68.     BEGIN RETURN MathL.pi / 2 - arcsin(n)
  69.     END arccos;
  70.     PROCEDURE arctan (n: LONGREAL): LONGREAL;
  71.     BEGIN RETURN MathL.arctan(n)
  72.     END arctan;
  73.     PROCEDURE exp (n: LONGREAL): LONGREAL;
  74.     BEGIN RETURN MathL.exp(n)
  75.     END exp;
  76.     PROCEDURE ln (n: LONGREAL): LONGREAL;
  77.     BEGIN
  78.         IF n > 0 THEN RETURN MathL.ln(n) ELSE err; RETURN 1 END
  79.     END ln;
  80.     PROCEDURE sqrt (n: LONGREAL): LONGREAL;
  81.     BEGIN
  82.         IF n >= 0 THEN RETURN MathL.sqrt(n) ELSE err; RETURN 1 END
  83.     END sqrt;
  84.     PROCEDURE Ch (ch: CHAR);
  85.     BEGIN Texts.Write(W, ch)
  86.     END Ch;
  87.     PROCEDURE Str (s: ARRAY OF CHAR);
  88.     BEGIN Texts.WriteString(W, s)
  89.     END Str;
  90.     PROCEDURE WrHex (n: LONGREAL);
  91.         VAR x, y: LONGINT; i: INTEGER;
  92.             a: ARRAY 10 OF CHAR;
  93.     BEGIN x := entier(n);
  94.         i := 0; Texts.Write(W, " ");
  95.         REPEAT y := x MOD 10H;
  96.             IF y < 10 THEN a[i] := CHR(y + 30H) ELSE a[i] := CHR(y + 37H) END;
  97.             x := x DIV 10H; INC(i)
  98.         UNTIL i = 8;
  99.         REPEAT DEC(i) UNTIL (i = 0) OR (a[i] # "0");
  100.         IF a[i] >= "A" THEN Texts.Write(W, "0") END;
  101.         WHILE i >= 0 DO Texts.Write(W, a[i]); DEC(i) END;
  102.         Texts.Write(W, "H")
  103.     END WrHex;
  104.     PROCEDURE WrInt (n: LONGREAL);
  105.     BEGIN Texts.Write(W, " "); Texts.WriteInt(W, entier(n), 0)
  106.     END WrInt;
  107.     PROCEDURE WrChar (n: LONGREAL);
  108.         VAR ch: CHAR;
  109.     BEGIN ch := CHR(entier(n));
  110.         IF (" " <= ch) & (ch < 7FX) OR (80X <= ch) & (ch < 0A0X) THEN Ch(" "); Ch(22X); Ch(ch); Ch(22X)
  111.         ELSE WrHex(ORD(ch))
  112.         END
  113.     END WrChar;
  114.     PROCEDURE WrReal (n: LONGREAL);
  115.         VAR x, y: LONGREAL;
  116.     BEGIN
  117.         IF (MIN(LONGINT) <= n) & (n <= MAX(LONGINT)) THEN x := ABS(n - ENTIER(SHORT(n)));
  118.             IF x < Eps THEN WrInt(n); RETURN END
  119.         END;
  120.         IF (MIN(REAL) <= n) & (n <= MAX(REAL)) THEN x := ABS(n - SHORT(n));
  121.             IF x < Eps THEN
  122.                 IF (-10000 < n) & (n < 10000) THEN Texts.WriteRealFix(W, short(n), 0, 6)
  123.                 ELSE Texts.WriteReal(W, short(n), 14)
  124.                 END;
  125.                 RETURN
  126.             END
  127.         END;
  128.         Texts.WriteLongReal(W, n, 23)
  129.     END WrReal;
  130.     PROCEDURE WrValue (n: LONGREAL);
  131.         VAR x: LONGREAL;
  132.     BEGIN
  133.         Str(" ="); WrReal(n);
  134.         IF (MIN(LONGINT) <= n) & (n <= MAX(LONGINT)) THEN x := ABS(n - ENTIER(SHORT(n)));
  135.             IF x < Eps THEN Str(" ="); WrHex(n); Str(" ="); WrInt(n);
  136.                 IF (0 <= n) & (n < 256) & (entier(n) = n) THEN Str(" ="); WrChar(n) END
  137.             END
  138.         END
  139.     END WrValue;
  140.     PROCEDURE Ln;
  141.     BEGIN Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
  142.     END Ln;
  143.     PROCEDURE Scan (VAR S: Texts.Scanner);
  144.         PROCEDURE hex (n: LONGINT): LONGINT;
  145.             VAR x, i: LONGINT; d: ARRAY 8 OF LONGINT;
  146.         BEGIN x := 0; i := 0;
  147.             REPEAT d[i] := n MOD 10; n := n DIV 10; INC(i) UNTIL n = 0;
  148.             WHILE i > 0 DO DEC(i); x := 16*x + d[i] END;
  149.             RETURN x
  150.         END hex;
  151.     BEGIN
  152.         IF S.eot THEN S.class := End
  153.         ELSIF S.nextCh = "/" THEN S.class := Texts.Char; S.c := "/"; Texts.Read(S, S.nextCh)
  154.         ELSE Texts.Scan(S)
  155.         END;
  156.         IF S.line # 0 THEN S.class := End END;
  157.         IF (S.class = Texts.Char) & (S.c = " ") THEN S.c := "-"
  158.         ELSIF (S.class = Texts.String) & (S.len = 2) THEN S.i := ORD(S.s[0]); S.class := Texts.Int
  159.         ELSIF (S.class = Texts.Int) & (S.nextCh = "X") THEN S.i := hex(S.i);
  160.             Texts.Read(S, S.nextCh)
  161.         END
  162.     END Scan;
  163.     PROCEDURE OpenScanner (VAR S: Texts.Scanner);
  164.         VAR text: Texts.Text; beg, end, time: LONGINT;
  165.     BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Scan(S);
  166.         IF (S.class = Texts.Char) & (S.c = "^") & (S.line = 0) THEN
  167.             Oberon.GetSelection(text, beg, end, time);
  168.             IF time >= lastTime THEN lastTime := time;
  169.                 Texts.OpenScanner(S, text, beg); Scan(S)
  170.             END
  171.         END;
  172.         IF S.line # 0 THEN S.class := Texts.Inval END
  173.     END OpenScanner;
  174.     PROCEDURE FindIdent (name: ARRAY OF CHAR; insert: BOOLEAN; VAR val: LONGREAL);
  175.         VAR s: Symbol;
  176.     BEGIN s := syms;
  177.         WHILE (s # NIL) & ((s.name # name) OR s.funct) DO s := s.next END;
  178.         IF insert THEN
  179.             IF s = NIL THEN NEW(s); s.next := syms; syms := s END;
  180.             COPY(name, s.name); s.funct := FALSE; s.val := val
  181.         ELSIF s # NIL THEN val := s.val
  182.         ELSE S.class := Texts.Inval
  183.         END
  184.     END FindIdent;
  185.     PROCEDURE FindFunct (name: ARRAY OF CHAR; insert: BOOLEAN; VAR sym: Symbol);
  186.         VAR s: Symbol;
  187.     BEGIN s := syms;
  188.         WHILE (s # NIL) & ((s.name # name) OR ~s.funct) DO s := s.next END;
  189.         IF insert THEN
  190.             IF s = NIL THEN s := sym; s.next := syms; syms := sym END;
  191.             COPY(name, s.name); s.funct := TRUE; s.val := 0
  192.         ELSIF s # NIL THEN sym := s
  193.         ELSE sym := NIL
  194.         END
  195.     END FindFunct;
  196.     PROCEDURE InitSyms;
  197.         VAR s: Symbol; n: LONGREAL; name: ARRAY 2 OF CHAR;
  198.     BEGIN name[1] := 0X;
  199.         name[0] := "e"; n := MathL.e; FindIdent(name, TRUE, n);
  200.         n := MathL.pi; FindIdent("pi", TRUE, n);
  201.         n := 0;
  202.         NEW(s); FindFunct("arctan", TRUE, s);
  203.         NEW(s); FindFunct("arccos", TRUE, s);
  204.         NEW(s); FindFunct("arcsin", TRUE, s);
  205.         NEW(s); FindFunct("cos", TRUE, s);
  206.         NEW(s); FindFunct("entier", TRUE, s);
  207.         NEW(s); FindFunct("exp", TRUE, s);
  208.         NEW(s); FindFunct("ln", TRUE, s);
  209.         NEW(s); FindFunct("short", TRUE, s);
  210.         NEW(s); FindFunct("sign", TRUE, s);
  211.         NEW(s); FindFunct("sin", TRUE, s);
  212.         NEW(s); FindFunct("sqrt", TRUE, s);
  213.         NEW(s); FindFunct("tan", TRUE, s)
  214.     END InitSyms;
  215.     PROCEDURE^ Expr (VAR n: LONGREAL);
  216.     PROCEDURE Functor (sym: Symbol; VAR n: LONGREAL);
  217.     BEGIN
  218.         IF sym.name = "arcsin" THEN n := arcsin(n)
  219.         ELSIF sym.name = "arccos" THEN n := arccos(n)
  220.         ELSIF sym.name = "arctan" THEN n := arctan(n)
  221.         ELSIF sym.name = "cos" THEN n := cos(n)
  222.         ELSIF sym.name = "exp" THEN n := exp(n)
  223.         ELSIF sym.name = "entier" THEN n := entier(n)
  224.         ELSIF sym.name = "ln" THEN n := ln(n)
  225.         ELSIF sym.name = "short" THEN n := short(n)
  226.         ELSIF sym.name = "sign" THEN n := sign(n)
  227.         ELSIF sym.name = "sin" THEN n := sin(n)
  228.         ELSIF sym.name = "sqrt" THEN n := sqrt(n)
  229.         ELSIF sym.name = "tan" THEN n := tan(n)
  230.         END
  231.     END Functor;
  232.     PROCEDURE Atom (VAR n: LONGREAL);
  233.         VAR sym: Symbol;
  234.     BEGIN
  235.         IF S.class = Texts.Int THEN n := S.i; Scan(S)
  236.         ELSIF S.class = Texts.Real THEN n := S.x; Scan(S)
  237.         ELSIF S.class = Texts.LongReal THEN n := S.y; Scan(S)
  238.         ELSIF S.class = Texts.Name THEN FindFunct(S.s, FALSE, sym);
  239.             IF sym # NIL THEN Scan(S); Atom(n);
  240.                 IF S.class # Texts.Inval THEN Functor(sym, n) END
  241.             ELSE FindIdent(S.s, FALSE, n);
  242.                 IF S.class # Texts.Inval THEN Scan(S) END
  243.             END
  244.         ELSIF (S.class = Texts.Char) & (S.c = "(") THEN Scan(S);
  245.             Expr(n);
  246.             IF (S.class = Texts.Char) & (S.c = ")") THEN Scan(S)
  247.             ELSE S.class := Texts.Inval
  248.             END
  249.         ELSE S.class := Texts.Inval
  250.         END
  251.     END Atom;
  252.     PROCEDURE Factor (VAR n: LONGREAL);
  253.         VAR x: LONGREAL;
  254.     BEGIN Atom(n);
  255.         WHILE (S.class = Texts.Char) & (S.c = "^") DO
  256.             Scan(S); Factor(x);
  257.             n := sign(n) * MathL.exp(MathL.ln(ABS(n)) * x)
  258.         END
  259.     END Factor;
  260.     PROCEDURE Term (VAR n: LONGREAL);
  261.         VAR x: LONGREAL; op: CHAR;
  262.     BEGIN Factor(n);
  263.         WHILE (S.class = Texts.Char)
  264.         & ((S.c = "*") OR (S.c = "/") OR (S.c = "%") OR (S.c = ">") OR (S.c = "<")) DO
  265.             op := S.c; Scan(S); Factor(x);
  266.             CASE op OF
  267.                 "*": n := n * x
  268.             |   "/": IF x # 0 THEN n := n / x ELSE err END
  269.             |   "%": IF x # 0 THEN n := entier(n) MOD entier(x) ELSE err END
  270.             |   "<": n := ASH(entier(n), entier(x))
  271.             |   ">": n := ASH(entier(n), -entier(x))
  272.             END
  273.         END
  274.     END Term;
  275.     PROCEDURE Expr (VAR n: LONGREAL);
  276.         VAR x: LONGREAL; op: CHAR;
  277.     BEGIN Term(n);
  278.         WHILE (S.class = Texts.Char) & ((S.c = "+") OR (S.c = "-")) OR (S.class = Texts.Int) DO
  279.             IF S.class = Texts.Char THEN op := S.c; Scan(S) ELSE op := "+" END;
  280.             Term(x);
  281.             CASE op OF
  282.                 "+": n := n + x
  283.             |   "-": n := n - x
  284.             END
  285.         END
  286.     END Expr;
  287.     PROCEDURE Hex*;    (** expr **)
  288.         VAR n: LONGREAL;
  289.     BEGIN Str("Calc.Hex"); OpenScanner(S); Expr(n);
  290.         IF S.class # Texts.Inval THEN WrHex(n) ELSE Str(" failed: bad argument") END;
  291.     END Hex;
  292.     PROCEDURE Dec*;    (** expr **)
  293.         VAR n: LONGREAL;
  294.     BEGIN Str("Calc.Dec"); OpenScanner(S); Expr(n);
  295.         IF S.class # Texts.Inval THEN WrInt(n) ELSE Str(" failed: bad argument") END;
  296.     END Dec;
  297.     PROCEDURE Real*;    (** expr **)
  298.         VAR n: LONGREAL;
  299.     BEGIN Str("Calc.Real"); OpenScanner(S); Expr(n);
  300.         IF S.class # Texts.Inval THEN WrReal(n) ELSE Str(" failed: bad argument") END;
  301.     END Real;
  302.     PROCEDURE Char*;    (** expr **)
  303.         VAR n: LONGREAL; ch: CHAR;
  304.     BEGIN Str("Calc.Char"); OpenScanner(S); Expr(n);
  305.         IF S.class # Texts.Inval THEN
  306.             IF (0 <= n) & (n < 256) THEN WrChar(n)
  307.             ELSE Str(" failed: not a character code")
  308.             END
  309.         ELSE Str(" failed: bad argument")
  310.         END;
  311.     END Char;
  312.     PROCEDURE Set*;    (** {name ":=" expr} "~" **)
  313.         VAR n: LONGREAL; name: ARRAY 32 OF CHAR;
  314.     BEGIN Str("Calc.Set"); Ln; OpenScanner(S);
  315.         WHILE S.class = Texts.Name DO COPY(S.s, name); Scan(S);
  316.             IF (S.class = Texts.Char) & (S.c = ":") & (S.nextCh = "=") THEN
  317.                 Scan(S); Scan(S); Expr(n)
  318.             ELSE S.class := Texts.Inval
  319.             END;
  320.             IF S.class # Texts.Inval THEN FindIdent(name, TRUE, n);
  321.                 IF S.class # Texts.Inval THEN Str("  "); Str(name); WrValue(n); Ln END
  322.             END
  323.         END;
  324.         IF S.class = Texts.Inval THEN Str("  failed: bad argument") END
  325.     END Set;
  326.     PROCEDURE List*;
  327.         VAR s: Symbol;
  328.     BEGIN Str("Calc.List"); Ln;
  329.         s := syms;
  330.         WHILE s # NIL DO
  331.             IF s.funct THEN Str("  "); Str(s.name) END;
  332.             s := s.next
  333.         END;
  334.         Ln;
  335.         s := syms;
  336.         WHILE s # NIL DO
  337.             IF ~s.funct THEN Str("  "); Str(s.name); WrValue(s.val); Ln END;
  338.             s := s.next
  339.         END
  340.     END List;
  341.     PROCEDURE Reset*;
  342.     BEGIN Str("Calc.Reset"); Ln; syms := NIL; InitSyms
  343.     END Reset;
  344. BEGIN Texts.OpenWriter(W); Texts.WriteString(W, Version); Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf);
  345.     lastTime := 0; syms := NIL; InitSyms
  346. END Calc.
  347.     Write.Open Calc.Tool
  348.     Calc.Reset
  349.     Calc.Set  cos := 33H  otto := 1000H  ~
  350.     Calc.List
  351.     Calc.Hex egon + otto
  352.     Calc.Dec egon * 2
  353.     Calc.Char "j" + 7
  354.     Calc.Real cos (193 * pi)
  355.